HPAVC/HPAVC CD-ROM.iso/pc/MYMUD21.ZIP/MMUD21.ZIP/SOURCE/11_STUFF.ZIP/DB2BIN.ZIP/DB.PAS

Pascal/Delphi Source File | 1993-06-12 | 12.0 KB | 586 lines

Unit DB;
Interface
Uses OldHead;


Type BufType   = Array[0..1023] Of Char;
     StrPtr    = ^BufType;
     AdvObject = Record
                  Name     : StrPtr;
                  Desc     : StrPtr;


                  Location : Integer;
                  Contents : Integer;
                  Exits    : Integer;
                  Next     : Integer;

                  Key      : StrPtr;
                  Fail     : StrPtr;
                  Success  : StrPtr;
                  OFail    : StrPtr;
                  OSuccess : StrPtr;

                  Owner    : Integer;
                  Pennies  : Integer;
                  Flags    : LongInt;
                  Password : StrPtr;
                 End;
     AdvPtr    = ^AdvObject;


Const MapSize = 5*1023;  { Maximal 5000 objects.. }

Var Map      : Array[0..MapSize] of AdvPtr;
    MapCount : Word;
    Buf      : BufType;

Procedure ReadDB;
Procedure SaveDB;
Procedure DisposeDB;
Procedure PrintRecordToScreen(ObjNr : Integer);
Function NewPlayer(NewName : String):Integer;


Function IsRoom(ObjNr : Word):Boolean;
Function IsThing(ObjNr : Word):Boolean;
Function IsExit(ObjNr : Word):Boolean;
Function IsPlayer(ObjNr : Word):Boolean;

Function IsWizard(ObjNr : Word):Boolean;
Function IsDark(ObjNr : Word):Boolean;
Function IsLinkOk(ObjNr : Word):Boolean;
Function IsTemple(ObjNr : Word):Boolean;
Function IsOwner(ObjNr : Word; PlayerNr : Word):Boolean;
Function Controls(Who,What : Integer):Boolean;
Function IsStiky(ObjNr : Word):Boolean;
{
Function IsBuilder(ObjNr : Word):Boolean;
Function IsHaven(ObjNr : Word):Boolean;
Function IsAbode(ObjNr : Word):Boolean;
}

Type GenderType = (None,Neuter,Female,Male);
Function WhichGender(ObjNr : Word):GenderType;

Function Asciiz2Str(B : BufType):String;
Implementation

{$F+} Function HeapFunc(Size : Word):Integer; {$F-}
Begin
 HeapFunc:=-1;
End;

Function Asciiz2Str(B : BufType):String;
Var T : Word;
    S : String;
Begin
T:=0;
While B[T]<>#00 Do
 Inc(T);
If T>255
   Then T:=255;
Move(B[0],S[1],T);
S[0]:=Chr(T);
Asciiz2Str:=S;
End;


Const BufPtr    : Integer = 0;
      MaxBuf    : Integer = 0;
      BufSize             = 10*1024;

Type  Buffer    = Array[0..BufSize] of Char;
Var   BufBuffer : Buffer;
      InpEOF    : Boolean;

Function ReadByte(Var Inp : File;Var EOB : Boolean):Char;
Begin
EOB:=False;
If (BufPtr=MaxBuf) Or  (MaxBuf=0)
   Then Begin
        FillChar(BufBuffer,SizeOf(BufBuffer),#00);
        BlockRead(Inp,BufBuffer,SizeOf(Bufbuffer),MaxBuf);
        If MaxBuf=0
           Then Begin
                ReadByte:=#00;
                EOB:=True;
                Exit;
                End;
        BufPtr:=0;
        End;
ReadByte:=BufBuffer[BufPtr];
Inc(BufPtr);
End;


Function NewObject:AdvPtr;
Var Tmp : AdvPtr;
Begin
New(Tmp);
If Tmp=NIL
   Then Begin
        WriteLn;
        WriteLn(' ■ Not enough memory!');
        Dispose(HeapOrg);
        Halt;
        End;
NewObject:=Tmp;
End;

Function ReadInteger(Var F : File): Integer;
Var S : String;
    I : Integer;
    E : Integer;
    C : Char;
Begin
S:='';
Repeat
 C:=ReadByte(F,InpEOF);
 Case C Of
   #13,#10 : ;
   Else S:=S+C;
 End; {Case}
Until C=#10;
Val(S,I,E);
If E<>0
   Then I:=0;
ReadInteger:=I;
End;

Function ReadLongInt(Var F : File):LongInt;
Var S : String;
    I : LongInt;
    E : Integer;
    C : Char;
Begin
S:='';
Repeat
 C:=ReadByte(F,InpEOF);
 Case C Of
   #13,#10 : ;
   Else S:=S+C;
 End; {Case}
Until C=#10;
Val(S,I,E);
If E<>0
   Then I:=0;
ReadLongInt:=I;
End;



Function ReadString(Var F : File;Var Len : Word):StrPtr;
Var C     : Char;
    Count : Word;
    Tmp   : StrPtr;
Begin
Count:=0;
FillChar(Buf,SizeOf(Buf),#00);
Repeat
 C:=ReadByte(F,InpEOF);
 Case C Of
  #13,#10 :;
  Else Begin
       Buf[Count]:=C;
       Inc(Count);
       End;
 End; {Case}
Until C=#10;
Inc(Count);
GetMem(Tmp,Count);
If Tmp=NIL
   Then Begin
        WriteLn(' ■ Not enough memory!');
        Dispose(HeapOrg);
        Halt;
        End;

Tmp^:=Buf;
ReadString:=Tmp;
Len:=Count;
End;


Function CheckBit(Flag : LongInt;BitMap : LongInt):Boolean;
Begin
CheckBit:=(Flag And BitMap)=BitMap;
End;

Function FieldLength(Var S : StrPtr):Word;
Var Tmp : Word;
Begin
Tmp:=0;
While S^[Tmp]<>#00 Do
 Inc(Tmp);
FieldLength:=Tmp+1;
End;


Procedure DisposeRecord(ObjNr : Integer);
Begin
With Map[ObjNr]^ Do
 Begin
 If Name<>Nil     Then FreeMem(Name,FieldLength(Name));
 If Desc<>Nil     Then FreeMem(Desc,FieldLength(Desc));
 If Key<>Nil      Then FreeMem(Key,FieldLength(Key));
 If Fail<>Nil     Then FreeMem(Fail,FieldLength(Fail));
 If Success<>Nil  Then FreeMem(Success,FieldLength(Success));
 If OFail<>Nil    Then FreeMem(OFail,FieldLength(OFail));
 If OSuccess<>Nil Then FreeMem(OSuccess,FieldLength(OSuccess));
 If Password<>Nil Then FreeMem(Password,FieldLength(Password));
 End; {With}
Dispose(Map[ObjNr]);
Map[ObjNr]:=NIL;
End;


Procedure DisposeDB;
Var T : Word;
Begin
For T:=0 To MapCount Do
 Begin
 If Map[T]<>NIL
    Then DisposeRecord(T);
 End;
End;


Procedure ReadDB;

Var F      : File;
    C      : Integer;
    Dum    : StrPtr;
    Len    : Word;
    Stop   : Boolean;

Begin
FillChar(Map,SizeOf(Map),#00);
If ParamCount=0
   Then Begin
        WriteLn(' ■ Syntax: ');
        WriteLn('   '+ParamStr(0)+' <DB file>');
        Halt;
        End;
Assign(F,ParamStr(1));
Reset(F,1);
If IoResult<>0
   Then Halt;
WriteLn(' ■ Reading database');

C:=0;
Stop:=False;
While Not Stop Do
 Begin
 Dum:=ReadString(F,Len);
 Stop:=Dum^[0]<>'#';
 If Not Stop
    Then Begin
         Write(' ■ Rec: ',Asciiz2Str(Dum^),' ',MemAvail:7,#13);
         FreeMem(Dum,Len);

         If MemAvail<2048
            Then Begin
                 WriteLn;
                 WriteLn(' ■ Not enough memory available!');
                 Dispose(HeapOrg);
                 Halt;
                 End;

         Map[C]:=NIL;
         Map[C]:=NewObject;

         With Map[C]^ Do
          Begin
          Name      :=ReadString(F,Len);
          Desc      :=ReadString(F,Len);

          Location  :=ReadInteger(F);
          Contents  :=ReadInteger(F);
          Exits     :=ReadInteger(F);
          Next      :=ReadInteger(F);

          Key       :=ReadString(F,Len);
          Fail      :=ReadString(F,Len);
          Success   :=ReadString(F,Len);
          OFail     :=ReadString(F,Len);
          OSuccess  :=ReadString(F,Len);

          Owner     :=ReadInteger(F);
          Pennies   :=ReadInteger(F);

          Flags     :=ReadLongInt(F);

          Password  :=ReadString(F,Len);
          End; {With}
         Inc(C);
         End;
 End;
WriteLn;
WriteLn(' ■ Ready..');
Close(F);
Dec(C);
MapCount:=C;
End; {ReadDB}



Procedure SaveDB;
Var Out : Text;
    C   : Integer;
    Dum : String[30];

Procedure WriteDBRecord(Var Out : Text;ObjNr : Integer);
Const NewField : Char = #$0A;
Var   Dum      : String[10];

Procedure WriteField(Var Out : Text;P : StrPtr);
Var C : Word;
Begin
C:=0;
While P^[C]<>#00 Do
 Begin
 Write(Out,P^[C]);
 Inc(C);
 End;
Write(Out,NewField);
End;

Begin
Write('#',ObjNr:3,#8#8#8#8);
With map[ObjNr]^ Do
 Begin
 Str(ObjNr,Dum);
 Write(Out,'#'+Dum,NewField);
 WriteField(Out,Name);
 WriteField(Out,Desc);
 Write(Out,Location,NewField);
 Write(Out,Contents,NewField);
 Write(Out,Exits,NewField);
 Write(Out,Next,NewField);

 WriteField(Out,Key);
 WriteField(Out,Fail);
 WriteField(Out,Success);
 WriteField(Out,OFail);
 WriteField(Out,OSuccess);

 Write(Out,Owner,NewField);
 Write(Out,Pennies,NewField);
 Write(Out,Flags,NewField);
 WriteField(Out,Password);
 End;
End;


Begin
Assign(Out,ParamStr(2));
Rewrite(Out);
For C:=0 To MapCount Do
 WriteDBRecord(Out,C);
Dum:='***END OF DUMP***'+#$0A;
Write(Out,Dum);
Close(Out);
If IoResult<>0
   Then ;
WriteLn('Ready');
End;


Function MakeString(Var P : StrPtr; S : String):Boolean;
Begin
MakeString:=False;
GetMem(P,Length(S)+1);
If P=Nil
   Then Exit;
FillChar(P^,Length(S)+1,#00);
Move(S[1],P^[0],Length(S));
MakeString:=True;
End;


Function NewPlayer(NewName : String):Integer;
Var Sex   : Char;
    Dum   : String;
Begin
NewPlayer:=NOTHING;
Inc(MapCount);
New(Map[MapCount]);
If Map[MapCount]=NIL
   Then Begin
        Dec(MapCount);
        Exit;
        End;

If Not MakeString(Map[MapCount]^.Name,NewName)
   Then Begin
        DisposeRecord(MapCount);
        Dec(MapCount);
        Exit;
        End;

With Map[MapCount]^ Do
 Begin
 Desc      := NIL;
 Contents  := NOTHING;
 Location  :=  0;
 Exits     :=  0;
 Next      := NOTHING;

 Fail      := Nil;
 Success   := Nil;
 OFail     := Nil;
 OSuccess  := Nil;

 Owner     := MapCount;
 Pennies   := 0;

 Flags     := Type_Player;

 WriteLn('Welkome new user!');

 Repeat
  Write('Are you Male/Femal/Neuter/Quit? [M/F/N/Q]: ');
  ReadLn(Sex);
  WriteLn;
 Until Upcase(Sex) in ['M','F','N','Q'];

 Case Upcase(Sex) Of
  'N' : Flags:=Flags Or (Gender_Neuter Shl Gender_Shift);
  'F' : Flags:=Flags Or (Gender_Female Shl Gender_Shift);
  'M' : Flags:=Flags Or (Gender_Male Shl Gender_Shift);
  'Q' : Begin
        DisposeRecord(MapCount);
        Dec(MapCount);
        Exit;
        End;
 End;

 write('Give a password: ');
 ReadLn(Dum);
 If Not MakeString(Map[MapCount]^.Password,Dum)
   Then Begin
        DisposeRecord(MapCount);
        Dec(MapCount);
        Exit;
        End;
 End;

Map[MapCount]^.Next:=Map[0]^.Contents;
Map[0]^.Contents:=MapCount;
Map[MapCount]^.Location:=0;
NewPlayer:=MapCount;
End;


Procedure PrintRecordToScreen(ObjNr : Integer);
Begin

With Map[ObjNr]^ Do
 Begin
  WriteLn('====================================================');
  WriteLn('Obj. Nr.: ',ObjNr);
  WriteLn('Name    : ',Asciiz2Str(Name^));
  WriteLn('Key     : ',ASciiz2Str(Key^));
  WriteLn('Location: ',Location);
  WriteLn('Next    : ',Next);
  WriteLn('Exits   : ',Exits);
  WriteLn('Contents: ',Contents);
  WriteLn('Owner   : ',Owner);
  WriteLn('Pennies : ',Pennies);
  WriteLn('Flags   : ',Flags);
  If IsPlayer(ObjNr)  Then Write('Player ');
  If IsThing(ObjNr)   Then Write('Thing ');
  If IsExit(ObjNr)    Then Write('Exit ');
  If IsRoom(ObjNr)    Then Write('Room ');
  If IsWizard(ObjNr)  Then Write('WIZ ');
  WriteLn;
  If IsDark(ObjNr)   Then Write('Dark ');
  If IsTemple(ObjNr) Then Write('Temple ');
  If IsLinkOk(ObjNr) Then Write('Link ');
  WriteLn;

  WriteLn('====================================================');
  End;
End;


Function IsRoom(ObjNr : Word):Boolean;
Begin
IsRoom:=(Map[ObjNr]^.Flags and TypeMask) = Type_Room;
End;

Function IsThing(ObjNr : Word):Boolean;
Begin
IsThing:=(Map[ObjNr]^.Flags and TypeMask) = Type_Thing;
End;

Function IsExit(ObjNr : Word):Boolean;
Begin
IsExit:=(Map[ObjNr]^.Flags and TypeMask) = Type_Exit;
End;

Function IsPlayer(ObjNr : Word):Boolean;
Begin
IsPlayer:=(Map[ObjNr]^.Flags and TypeMask) = Type_Player;
End;

Function IsWizard(ObjNr : Word):Boolean;
Begin
IsWizard:=(Map[ObjNr]^.Flags And Wizard)=Wizard;
End;

Function IsDark(ObjNr : Word):Boolean;
Begin
IsDark:=(Map[ObjNr]^.Flags And Dark)=Dark;
End;

Function IsLinkOk(ObjNr : Word):Boolean;
Begin
IsLinkOk:=(Map[ObjNr]^.Flags And Link_Ok)=Link_Ok;
End;

Function IsTemple(ObjNr : Word):Boolean;
Begin
IsTemple:=(Map[ObjNr]^.Flags And Temple)=Temple;
End;

Function IsOwner(ObjNr : Word; PlayerNr : Word):Boolean;
Begin
IsOwner:=Map[ObjNr]^.Owner=PlayerNr;
End;


Function IsStiky(ObjNr : Word):Boolean;
Begin
IsStiky:=(Map[ObjNr]^.Flags And STIKY) = STIKY;
End;

{
Function IsBuilder(ObjNr : Word):Boolean;
Function IsHaven(ObjNr : Word):Boolean;
Function IsAbode(ObjNr : Word):Boolean;
}

Function Controls(Who,What : Integer):Boolean;
Begin
Controls:=IsWizard(Who) Or IsOwner(Who,What);
End;



Function WhichGender(ObjNr : Word):GenderType;
Begin
WhichGender:=GenderType( (Map[ObjNr]^.Flags And Gender_Mask) Shr Gender_Shift);
End;


Begin
HeapError:=@HeapFunc;
InpEOF:=False;



End.